;;;; RUN-PROGRAM and friends, a facility for running Unix programs
;;;; from inside SBCL

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.)

;;;; hacking the Unix environment
;;;;
;;;; In the original CMU CL code that LOAD-FOREIGN is derived from, the
;;;; Unix environment (as in "man environ") was represented as an
;;;; alist from keywords to strings, so that e.g. the Unix environment
;;;;   "SHELL=/bin/bash" "HOME=/root" "PAGER=less"
;;;; was represented as
;;;;   ((:SHELL . "/bin/bash") (:HOME . "/root") (:PAGER "less"))
;;;; This had a few problems in principle: the mapping into
;;;; keyword symbols smashed the case of environment
;;;; variables, and the whole mapping depended on the presence of
;;;; #\= characters in the environment strings. In practice these
;;;; problems weren't hugely important, since conventionally environment
;;;; variables are uppercase strings followed by #\= followed by
;;;; arbitrary data. However, since it's so manifestly not The Right
;;;; Thing to make code which breaks unnecessarily on input which
;;;; doesn't follow what is, after all, only a tradition, we've switched
;;;; formats in SBCL, so that the fundamental environment list
;;;; is just a list of strings, with a one-to-one-correspondence
;;;; to the C-level representation. I.e., in the example above,
;;;; the SBCL representation is
;;;;   '("SHELL=/bin/bash" "HOME=/root" "PAGER=less")
;;;; CMU CL's implementation is currently supported to help with porting.
;;;;
;;;; It's not obvious that this code belongs here (instead of e.g. in
;;;; unix.lisp), since it has only a weak logical connection with
;;;; RUN-PROGRAM. However, physically it's convenient to put it here.
;;;; It's not needed at cold init, so we *can* put it in this
;;;; warm-loaded file. And by putting it in this warm-loaded file, we
;;;; make it easy for it to get to the C-level 'environ' variable.
;;;; which (at least in sbcl-0.6.10 on Red Hat Linux 6.2) is not
;;;; visible at GENESIS time.

#-win32
(progn
  (define-alien-routine wrapped-environ (* c-string))
  (defun posix-environ ()
    "Return the Unix environment (\"man environ\") as a list of SIMPLE-STRINGs."
    (c-strings->string-list (wrapped-environ))))

#+win32
(progn
  (defun decode-windows-environment (environment)
    (loop until (zerop (sap-ref-8 environment 0))
          collect
          (let ((string (sb-alien::c-string-to-string environment
                                                      (sb-alien::default-c-string-external-format)
                                                      'character)))
            (loop for value = (sap-ref-8 environment 0)
                  do (setf environment (sap+ environment 1))
                  until (zerop value))
            string)))

  (defun encode-windows-environment (list)
    (let* ((external-format (sb-alien::default-c-string-external-format))
           octets
           (length 1)) ;; 1 for \0 at the very end
      (setf octets
            (loop for x in list
                  for octet =
                  (string-to-octets x :external-format external-format
                                      :null-terminate t)
                  collect octet
                  do
                  (incf length (length octet))))
      (let ((mem (allocate-system-memory length))
            (index 0))

        (loop for string in octets
              for length = (length string)
              do
              (copy-ub8-to-system-area string 0 mem index length)
              (incf index length))
        (setf (sap-ref-8 mem index) 0)
        (values mem mem length))))

  (defun posix-environ ()
    (decode-windows-environment
     (alien-funcall (extern-alien "GetEnvironmentStrings"
                                  (function system-area-pointer))))))

;;; Convert from a CMU CL representation of a Unix environment to a
;;; SBCL representation.
(defun unix-environment-sbcl-from-cmucl (cmucl)
  (mapcar
   (lambda (cons)
     (destructuring-bind (key . val) cons
       (declare (type keyword key) (string val))
       (concatenate 'simple-string (symbol-name key) "=" val)))
   cmucl))

#-win32
(define-alien-routine ("waitpid" c-waitpid) int
  (pid int)
  (status int :out)
  (options int))

#-win32
(defun waitpid (pid)
  "Return any available status information on child process with PID."
  (multiple-value-bind (pid status)
      (c-waitpid pid
                 (logior sb-unix:wnohang sb-unix:wuntraced sb-unix:wcontinued))
    (cond ((or (minusp pid)
               (zerop pid))
           (values nil nil nil))
          ((wifcontinued status)
           (values :running
                   nil
                   nil))
          ((wifstopped status)
           (values :stopped
                   (ldb (byte 8 8) status)
                   nil))
          ((zerop (ldb (byte 7 0) status))
           (values :exited
                   (ldb (byte 8 8) status)
                   nil))
          (t
           (let ((signal (ldb (byte 7 0) status)))
             (values (if (position signal
                                   #.(vector
                                      sb-unix:sigstop
                                      sb-unix:sigtstp
                                      sb-unix:sigttin
                                      sb-unix:sigttou))
                         :stopped
                         :signaled)
                     signal
                     (not (zerop (ldb (byte 1 7) status)))))))))

#-win32
(define-alien-routine wifcontinued boolean
  (status int))

#-win32
(define-alien-routine wifstopped boolean
  (status int))

;;;; process control stuff
(define-load-time-global *active-processes* nil
  "List of process structures for all active processes.")

(define-load-time-global *active-processes-lock*
  (sb-thread:make-mutex :name "Lock for active processes."))

;;; *ACTIVE-PROCESSES* can be accessed from multiple threads so a
;;; mutex is needed. More importantly the sigchld signal handler also
;;; accesses it, that's why we need without-interrupts.
(defmacro with-active-processes-lock (() &body body)
  `(sb-thread::with-system-mutex (*active-processes-lock*)
     ,@body))

(deftype process-status ()
  '(member :running :stopped :exited :signaled))

(defstruct (process (:copier nil))
  (pid     nil :type word :read-only t) ; PID of child process
  (%status nil :type process-status)
  %exit-code                            ; either exit code or signal
  core-dumped                           ; T if a core image was dumped
  #-win32 pty                           ; stream to child's pty, or NIL
  input                                 ; stream to child's input, or NIL
  output                                ; stream from child's output, or NIL
  error                                 ; stream from child's error output, or NIL
  status-hook                           ; closure to call when PROC changes status
  plist                                 ; a place for clients to stash things
  (cookie nil :type cons :read-only t)  ; list of the number of pipes from the subproc
  #+win32 copiers ; list of sb-win32::io-copier
  #+win32 (handle nil :type (or null (signed-byte 32))))

(defmethod print-object ((process process) stream)
  (print-unreadable-object (process stream :type t)
    (let ((status (process-status process)))
      (if (eq :exited status)
          (format stream "~S ~S" status (process-%exit-code process))
          (format stream "~S ~S" (process-pid process) status)))
    process))

#+win32
(define-alien-routine ("GetExitCodeProcess" get-exit-code-process)
    int
  (handle unsigned) (exit-code unsigned :out))

(defun process-exit-code (process)
  "Return the exit code of PROCESS."
  (or (process-%exit-code process)
      (progn (get-processes-status-changes)
             (process-%exit-code process))))

(defun process-status (process)
  "Return the current status of PROCESS.  The result is one of :RUNNING,
   :STOPPED, :EXITED, or :SIGNALED."
  (get-processes-status-changes)
  (process-%status process))

(setf (documentation 'process-exit-code 'function)
      "The exit code or the signal of a stopped process."
      (documentation 'process-core-dumped 'function)
      "T if a core image was dumped by the process."
      (documentation 'process-pty 'function)
      "The pty stream of the process or NIL."
      (documentation 'process-input 'function)
      "The input stream of the process or NIL."
      (documentation 'process-output 'function)
      "The output stream of the process or NIL."
      (documentation 'process-error 'function)
      "The error stream of the process or NIL."
      (documentation 'process-status-hook 'function) "A function that is called when PROCESS changes its status.
The function is called with PROCESS as its only argument."
      (documentation 'process-plist 'function)
      "A place for clients to stash things."
      (documentation 'process-p 'function)
      "T if OBJECT is a PROCESS, NIL otherwise."
      (documentation 'process-pid 'function) "The pid of the child process.")

(defun process-wait (process &optional check-for-stopped)
  "Wait for PROCESS to quit running for some reason. When
CHECK-FOR-STOPPED is T, also returns when PROCESS is stopped. Returns
PROCESS."
  (declare (ignorable check-for-stopped))
  #+win32
  (sb-win32::win32-process-wait process)
  #-win32
  (loop
      (case (process-status process)
        (:running)
        (:stopped
         (when check-for-stopped
           (return)))
        (t
         (when (zerop (car (process-cookie process)))
           (return))))
      (serve-all-events 1))
  process)

#-win32
;;; Find the current foreground process group id.
(defun find-current-foreground-process (proc)
  (with-alien ((result int))
    (multiple-value-bind
          (wonp error)
        (sb-unix:unix-ioctl (fd-stream-fd (process-pty proc))
                            sb-unix:TIOCGPGRP
                            (alien-sap (addr result)))
      (unless wonp
        (error "TIOCPGRP ioctl failed: ~S" (strerror error)))
      result))
  (process-pid proc))

#-win32
(defun process-kill (process signal &optional (whom :pid))
  "Hand SIGNAL to PROCESS. If WHOM is :PID, use the kill Unix system call. If
   WHOM is :PROCESS-GROUP, use the killpg Unix system call. If WHOM is
   :PTY-PROCESS-GROUP deliver the signal to whichever process group is
   currently in the foreground."
  (let ((pid (ecase whom
               ((:pid :process-group)
                (process-pid process))
               (:pty-process-group
                (find-current-foreground-process process)))))
    (let ((result (if (eq whom :process-group)
                      (sb-unix:unix-killpg pid signal)
                      (sb-unix:unix-kill pid signal))))
      (or (zerop result)
          (values nil (sb-unix::get-errno))))))

#+win32
(defun process-kill (process signal &optional (whom :pid))
  (declare (ignore signal whom))
  (get-processes-status-changes)
  (let ((handle (process-handle process)))
    (when handle
      (prog1 (sb-win32::terminate-process handle 1)
        (get-processes-status-changes)))))

(defun process-alive-p (process)
  "Return T if PROCESS is still alive, NIL otherwise."
  (let ((status (process-status process)))
    (if (or (eq status :running)
            (eq status :stopped))
        t
        nil)))

(defun process-close (process)
  "Close all streams connected to PROCESS and stop maintaining the
status slot."
  (macrolet ((frob (stream abort)
               `(when ,stream (close ,stream :abort ,abort))))
    #-win32
    (frob (process-pty process) t)   ; Don't FLUSH-OUTPUT to dead process,
    (frob (process-input process) t) ; .. 'cause it will generate SIGPIPE.
    (frob (process-output process) nil)
    (frob (process-error process) nil))
  ;; FIXME: Given that the status-slot is no longer updated,
  ;; maybe it should be set to :CLOSED, or similar?
  (with-active-processes-lock ()
   (setf *active-processes* (delete process *active-processes*)))
  #+win32
  (let ((handle (shiftf (process-handle process) nil)))
    (when handle
      (or (plusp (sb-win32:close-handle handle))
          (sb-win32::win32-error 'process-close))))
  process)

(defun get-processes-status-changes ()
  (let (changed)
    (with-active-processes-lock ()
      (setf *active-processes*
            (delete-if #-win32
                       (lambda (proc)
                         ;; Wait only on pids belonging to processes
                         ;; started by RUN-PROGRAM. There used to be a
                         ;; WAIT3 call here, but that makes direct
                         ;; WAIT, WAITPID usage impossible due to the
                         ;; race with the SIGCHLD signal handler.
                         (multiple-value-bind (status code core)
                             (waitpid (process-pid proc))
                           (when status
                             (setf (process-%status proc) status)
                             (setf (process-%exit-code proc) code)
                             (when (process-status-hook proc)
                               (push proc changed))
                             (when (member status '(:exited :signaled))
                               (setf (process-core-dumped proc) core)
                               t))))
                       #+win32
                       (lambda (proc)
                         (let ((handle (process-handle proc)))
                           (when handle
                             (multiple-value-bind (ok code)
                                 (sb-win32::get-exit-code-process handle)
                               (when (and (plusp ok)
                                          (/= code sb-win32::still-active))
                                 (setf (process-%status proc) :exited
                                       (process-%exit-code proc) code)
                                 (sb-win32::close-handle handle)
                                 (setf (process-handle proc) nil)
                                 (when (process-status-hook proc)
                                   (push proc changed))
                                 t)))))
                       *active-processes*)))
    ;; Can't call the hooks before all the processes have been deal
    ;; with, as calling a hook may cause re-entry to
    ;; GET-PROCESS-STATUS-CHANGES. That may be OK when using waitpid,
    ;; but in the Windows implementation it would be deeply bad.
    (dolist (proc changed)
      (let ((hook (process-status-hook proc)))
        (funcall hook proc)))))

;;;; RUN-PROGRAM and close friends

;;; list of file descriptors to close when RUN-PROGRAM exits due to an error
(defvar *close-on-error* nil)

;;; list of file descriptors to close when RUN-PROGRAM returns in the parent
(defvar *close-in-parent* nil)

;;; list of handlers installed by RUN-PROGRAM.
(defvar *handlers-installed* nil)

;;; Find an unused pty. Return three values: the file descriptor for
;;; the master side of the pty, the file descriptor for the slave side
;;; of the pty, and the name of the tty device for the slave side.
#-(or win32 openbsd freebsd dragonfly)
(progn
  (define-alien-routine ptsname c-string (fd int))
  (define-alien-routine grantpt boolean (fd int))
  (define-alien-routine unlockpt boolean (fd int))

  (defun find-a-pty ()
    ;; First try to use the Unix98 pty api.
    (let* ((master-name (coerce (format nil "/dev/ptmx") 'base-string))
           (master-fd (sb-unix:unix-open master-name
                                         (logior sb-unix:o_rdwr
                                                 sb-unix:o_noctty)
                                         #o666)))
      (when master-fd
        (grantpt master-fd)
        (unlockpt master-fd)
        (let* ((slave-name (ptsname master-fd))
               (slave-fd (sb-unix:unix-open slave-name
                                            (logior sb-unix:o_rdwr
                                                    sb-unix:o_noctty)
                                            #o666)))
          (when slave-fd
            (return-from find-a-pty
              (values master-fd
                      slave-fd
                      slave-name)))
          (sb-unix:unix-close master-fd))
        (error "could not find a pty")))
    ;; No dice, try using the old-school method.
    (dolist (char '(#\p #\q))
      (dotimes (digit 16)
        (let* ((master-name (coerce (format nil "/dev/pty~C~X" char digit)
                                    'base-string))
               (master-fd (sb-unix:unix-open master-name
                                             (logior sb-unix:o_rdwr
                                                     sb-unix:o_noctty)
                                             #o666)))
          (when master-fd
            (let* ((slave-name (coerce (format nil "/dev/tty~C~X" char digit)
                                       'base-string))
                   (slave-fd (sb-unix:unix-open slave-name
                                                (logior sb-unix:o_rdwr
                                                        sb-unix:o_noctty)
                                                #o666)))
              (when slave-fd
                (return-from find-a-pty
                  (values master-fd
                          slave-fd
                          slave-name)))
              (sb-unix:unix-close master-fd))))))
    (error "could not find a pty")))

#+(or openbsd freebsd dragonfly)
(progn
  (define-alien-routine openpty int (amaster int :out) (aslave int :out)
                        (name (* char)) (termp (* t)) (winp (* t)))
  (defun find-a-pty ()
    (with-alien ((name-buf (array char #.path-max)))
      (multiple-value-bind (return-val master-fd slave-fd)
          (openpty (cast name-buf (* char)) nil nil)
        (if (zerop return-val)
            (values master-fd
                    slave-fd
                    (sb-alien::c-string-to-string (alien-sap name-buf)
                                                  (sb-impl::default-external-format)
                                                  'character))
            (error "could not find a pty"))))))

#-win32
(defun open-pty (pty cookie &key (external-format :default))
  (when pty
    (multiple-value-bind
          (master slave name)
        (find-a-pty)
      (push master *close-on-error*)
      (push slave *close-in-parent*)
      (when (streamp pty)
        (multiple-value-bind (new-fd errno) (sb-unix:unix-dup master)
          (unless new-fd
            (error "couldn't SB-UNIX:UNIX-DUP ~W: ~A" master (strerror errno)))
          (push new-fd *close-on-error*)
          (copy-descriptor-to-stream new-fd pty cookie external-format)))
      (values name
              (make-fd-stream master :input t :output t
                                     :external-format external-format
                                     :element-type :default
                                     :dual-channel-p t)))))

;; Null terminate strings only C-side: otherwise we can run into
;; A-T-S-L even for simple encodings like ASCII.  Multibyte encodings
;; may need more than a single byte of zeros; assume 4 byte is enough
;; for everyone.
#-win32
(defmacro round-null-terminated-bytes-to-words (n)
  `(logandc2 (the sb-vm:signed-word (+ (the fixnum ,n)
                                       4 (1- sb-vm:n-machine-word-bytes)))
             (1- sb-vm:n-machine-word-bytes)))

#-win32
(defun string-list-to-c-strvec (string-list)
  (let* (;; We need an extra for the null, and an extra 'cause exect
         ;; clobbers argv[-1].
         (vec-bytes (* sb-vm:n-machine-word-bytes (+ (length string-list) 2)))
         (octet-vector-list (mapcar (lambda (s)
                                      (string-to-octets s))
                                    string-list))
         (string-bytes (reduce #'+ octet-vector-list
                               :key (lambda (s)
                                      (round-null-terminated-bytes-to-words
                                       (length s)))))
         (total-bytes (+ string-bytes vec-bytes))
         ;; Memory to hold the vector of pointers and all the strings.
         (vec-sap (allocate-system-memory total-bytes))
         (string-sap (sap+ vec-sap vec-bytes))
         ;; Index starts from [1]!
         (vec-index-offset sb-vm:n-machine-word-bytes))
    (declare (sb-vm:signed-word vec-bytes)
             (sb-vm:word string-bytes total-bytes)
             (system-area-pointer vec-sap string-sap))
    (dolist (octets octet-vector-list)
      (declare (type (simple-array (unsigned-byte 8) (*)) octets))
      (let ((size (length octets)))
        ;; Copy string.
        (sb-kernel:copy-ub8-to-system-area octets 0 string-sap 0 size)
        ;; NULL-terminate it
        (sb-kernel:system-area-ub8-fill 0 string-sap size 4)
        ;; Put the pointer in the vector.
        (setf (sap-ref-sap vec-sap vec-index-offset) string-sap)
        ;; Advance string-sap for the next string.
        (setf string-sap (sap+ string-sap
                               (round-null-terminated-bytes-to-words size)))
        (incf vec-index-offset sb-vm:n-machine-word-bytes)))
    ;; Final null pointer.
    (setf (sap-ref-sap vec-sap vec-index-offset) (int-sap 0))
    (values vec-sap (sap+ vec-sap sb-vm:n-machine-word-bytes) total-bytes)))

#-win32
(defmacro with-args ((var str-list) &body body)
  (with-unique-names (sap size)
    `(multiple-value-bind (,sap ,var ,size)
         (string-list-to-c-strvec ,str-list)
       (unwind-protect
            (progn
              ,@body)
         (deallocate-system-memory ,sap ,size)))))

(defmacro with-environment ((var str-list &key null) &body body)
  (once-only ((null null))
    (with-unique-names (sap size)
      `(multiple-value-bind (,sap ,var ,size)
           (if ,null
               (values nil (int-sap 0))
               #-win32 (string-list-to-c-strvec ,str-list)
               #+win32 (encode-windows-environment ,str-list))
         (unwind-protect
              (progn
                ,@body)
           (unless ,null
             (deallocate-system-memory ,sap ,size)))))))
#-win32
(define-alien-routine spawn
     int
  (program c-string)
  (argv (* c-string))
  (stdin int)
  (stdout int)
  (stderr int)
  (search int)
  (envp (* c-string))
  (pty-name c-string)
  (wait int)
  (dir c-string))

#+win32
(defun escape-arg (arg stream)
  ;; Normally, #\\ doesn't have to be escaped
  ;; But if #\" follows #\\, then they have to be escaped.
  ;; Do that by counting the number of consequent backslashes, and
  ;; upon encoutering #\" immediately after them, output the same
  ;; number of backslashes, plus one for #\"
  (write-char #\" stream)
  (loop with slashes = 0
        for i below (length arg)
        for previous-char = #\a then char
        for char = (char arg i)
        do
        (case char
          (#\"
           (loop repeat slashes
                 do (write-char #\\ stream))
           (write-string "\\\"" stream))
          (t
           (write-char char stream)))
        (case char
          (#\\
           (incf slashes))
          (t
           (setf slashes 0)))
        finally
        ;; The final #\" counts too, but doesn't need to be escaped itself
        (loop repeat slashes
              do (write-char #\\ stream)))
  (write-char #\" stream))

#+win32
(defun prepare-args (args escape)
  (with-simple-output-to-string (str)
    (loop for (arg . rest) on args
          do
          (cond ((and escape
                      (find-if (lambda (c) (find c '(#\Space #\Tab #\")))
                               arg))
                 (escape-arg arg str))
                (t
                 (write-string arg str)))
          (when rest
            (write-char #\Space str)))))

#-win32
(defun prepare-args (args)
  (if (every #'simple-string-p args)
      args
      (loop for arg in args
            collect (coerce arg 'simple-string))))

;;; FIXME: There shouldn't be two semiredundant versions of the
;;; documentation. Since this is a public extension function, the
;;; documentation should be in the doc string. So all information from
;;; this comment should be merged into the doc string, and then this
;;; comment can go away.
;;;
;;; RUN-PROGRAM uses fork() and execve() to run a different program.
;;; Strange stuff happens to keep the Unix state of the world
;;; coherent.
;;;
;;; The child process needs to get its input from somewhere, and send
;;; its output (both standard and error) to somewhere. We have to do
;;; different things depending on where these somewheres really are.
;;;
;;; For input, there are five options:
;;;  -- T: Just leave fd 0 alone. Pretty simple.
;;;  -- "file": Read from the file. We need to open the file and
;;;     pull the descriptor out of the stream. The parent should close
;;;     this stream after the child is up and running to free any
;;;     storage used in the parent.
;;;  -- NIL: Same as "file", but use "/dev/null" as the file.
;;;  -- :STREAM: Use Unix pipe() to create two descriptors. Use
;;;     SB-SYS:MAKE-FD-STREAM to create the output stream on the
;;;     writeable descriptor, and pass the readable descriptor to
;;;     the child. The parent must close the readable descriptor for
;;;     EOF to be passed up correctly.
;;;  -- a stream: If it's a fd-stream, just pull the descriptor out
;;;     of it. Otherwise make a pipe as in :STREAM, and copy
;;;     everything across.
;;;
;;; For output, there are five options:
;;;  -- T: Leave descriptor 1 alone.
;;;  -- "file": dump output to the file.
;;;  -- NIL: dump output to /dev/null.
;;;  -- :STREAM: return a stream that can be read from.
;;;  -- a stream: if it's a fd-stream, use the descriptor in it.
;;;     Otherwise, copy stuff from output to stream.
;;;
;;; For error, there are all the same options as output plus:
;;;  -- :OUTPUT: redirect to the same place as output.
;;;
;;; RUN-PROGRAM returns a PROCESS structure for the process if
;;; the fork worked, and NIL if it did not.
(defun run-program (program args
                    &key
                    (env nil env-p)
                    (environment
                     (when env-p
                       (unix-environment-sbcl-from-cmucl env))
                     environment-p)
                    (wait t)
                    search
                    #-win32 pty
                    input
                    if-input-does-not-exist
                    output
                    (if-output-exists :error)
                    (error :output)
                    (if-error-exists :error)
                    status-hook
                    (external-format :default)
                    directory
                    #+win32 (escape-arguments t))
  "RUN-PROGRAM creates a new process specified by PROGRAM.
ARGS are passed as the arguments to the program.

The program arguments and the environment are encoded using the
default external format for streams.

RUN-PROGRAM will return a PROCESS structure. See the CMU Common Lisp
Users Manual for details about the PROCESS structure.

   Notes about Unix environments (as in the :ENVIRONMENT and :ENV args):

   - The SBCL implementation of RUN-PROGRAM, like Perl and many other
     programs, but unlike the original CMU CL implementation, copies
     the Unix environment by default.
   - Running Unix programs from a setuid process, or in any other
     situation where the Unix environment is under the control of someone
     else, is a mother lode of security problems. If you are contemplating
     doing this, read about it first. (The Perl community has a lot of good
     documentation about this and other security issues in script-like
     programs.)

   The &KEY arguments have the following meanings:
   :ENVIRONMENT
      a list of STRINGs describing the new Unix environment
      (as in \"man environ\"). The default is to copy the environment of
      the current process.
   :ENV
      an alternative lossy representation of the new Unix environment,
      for compatibility with CMU CL
   :SEARCH
      Look for PROGRAM in each of the directories in the child's $PATH
      environment variable.  Otherwise an absolute pathname is required.
   :WAIT
      If non-NIL (default), wait until the created process finishes.  If
      NIL, continue running Lisp until the program finishes.
   :PTY (not supported on win32)
      Either T, NIL, or a stream.  Unless NIL, the subprocess is established
      under a PTY.  If :pty is a stream, all output to this pty is sent to
      this stream, otherwise the PROCESS-PTY slot is filled in with a stream
      connected to pty that can read output and write input.
   :INPUT
      Either T, NIL, a pathname, a stream, or :STREAM.
      T: the standard input for the current process is inherited.
      NIL: /dev/null (nul on win32) is used.
      pathname: the specified file is used.
      stream: all the input is read from that stream and sent to the
      subprocess.
      :STREAM: the PROCESS-INPUT slot is filled in with a stream that sends
      its output to the process.
      Defaults to NIL.
   :IF-INPUT-DOES-NOT-EXIST (when :INPUT is the name of a file)
      can be one of:
         :ERROR to generate an error
         :CREATE to create an empty file
         NIL (the default) to return NIL from RUN-PROGRAM
   :OUTPUT
      Either T, NIL, a pathname, a stream, or :STREAM.
      T: the standard output for the current process is inherited.
      NIL: /dev/null (nul on win32) is used.
      pathname: the specified file is used.
      stream: all the output from the process is written to this stream.
      :STREAM: the PROCESS-OUTPUT slot is filled in with a stream that can be
      read to get the output.
      Defaults to NIL.
   :ERROR
      Same as :OUTPUT, additionally accepts :OUTPUT, making all error
      output routed to the same place as normal output.
      Defaults to :OUTPUT.
   :IF-OUTPUT-EXISTS (when :OUTPUT is the name of a file)
      can be one of:
         :ERROR (the default) to generate an error
         :SUPERSEDE to supersede the file with output from the program
         :APPEND to append output from the program to the file
         NIL to return NIL from RUN-PROGRAM, without doing anything
   :IF-ERROR-EXISTS
      Same as :IF-OUTPUT-EXISTS, controlling :ERROR output to files.
      Ignored when :ERROR :OUTPUT.
      Defaults to :ERROR.
   :STATUS-HOOK
      This is a function the system calls whenever the status of the
      process changes.  The function takes the process as an argument.
   :EXTERNAL-FORMAT
      The external-format to use for :INPUT, :OUTPUT, and :ERROR :STREAMs.
   :DIRECTORY
      Specifies the directory in which the program should be run.
      NIL (the default) means the directory is unchanged.

   Windows specific options:
   :ESCAPE-ARGUMENTS (default T)
      Controls escaping of the arguments passed to CreateProcess."
  (when (and env-p environment-p)
    (error "can't specify :ENV and :ENVIRONMENT simultaneously"))
  (let* (;; Clear various specials used by GET-DESCRIPTOR-FOR to
         ;; communicate cleanup info.
         *close-on-error*
         *close-in-parent*
         *handlers-installed*
         ;; Establish PROC at this level so that we can return it.
         proc
         (progname (native-namestring program))
         (args (prepare-args (cons progname args) #+win32 escape-arguments))
         (directory (and directory (native-namestring directory)))
         ;; Gag.
         (cookie (list 0)))
    (unwind-protect
         ;; Note: despite the WITH-* names, these macros don't
         ;; expand into UNWIND-PROTECT forms.  They're just
         ;; syntactic sugar to make the rest of the routine slightly
         ;; easier to read.
         (macrolet ((with-fd-and-stream-for (((fd stream) which &rest args)
                                             &body body)
                      `(multiple-value-bind (,fd ,stream)
                           ,(ecase which
                              ((:input :output)
                               `(get-descriptor-for ,which ,@args))
                              (:error
                               `(if (eq ,(first args) :output)
                                    ;; kludge: we expand into
                                    ;; hard-coded symbols here.
                                    (values stdout output-stream)
                                    (get-descriptor-for ,which ,@args))))
                         (unless ,fd
                           (return-from run-program))
                         ,@body))
                    (with-open-pty (((pty-name pty-stream) (pty cookie))
                                    &body body)
                      (declare (ignorable pty-name pty-stream pty cookie))
                      #+win32
                      `(progn ,@body)
                      #-win32
                      `(multiple-value-bind (,pty-name ,pty-stream)
                           (open-pty ,pty ,cookie :external-format external-format)
                         ,@body)))
           (with-fd-and-stream-for ((stdin input-stream) :input
                                    input cookie
                                    :direction :input
                                    :if-does-not-exist if-input-does-not-exist
                                    :external-format external-format
                                    :wait wait)
             (with-fd-and-stream-for ((stdout output-stream) :output
                                      output cookie
                                      :direction :output
                                      :if-exists if-output-exists
                                      :external-format external-format)
               (with-fd-and-stream-for ((stderr error-stream)  :error
                                        error cookie
                                        :direction :output
                                        :if-exists if-error-exists
                                        :external-format external-format)
                 (with-open-pty ((pty-name pty-stream) (pty cookie))
                   ;; Make sure we are not notified about the child
                   ;; death before we have installed the PROCESS
                   ;; structure in *ACTIVE-PROCESSES*.
                   (let (child #+win32 handle)
                     (with-active-processes-lock ()
                       (with-environment (environment-vec environment
                                          :null (not (or environment environment-p)))
                         (setf (values child #+win32 handle)
                               #+win32
                               (sb-win32::mswin-spawn
                                progname
                                args
                                stdin stdout stderr
                                search environment-vec directory)
                               #-win32
                               (with-args (args-vec args)
                                 (without-gcing
                                   (spawn progname args-vec
                                          stdin stdout stderr
                                          (if search 1 0)
                                          environment-vec pty-name
                                          (if wait 1 0) directory))))
                         (unless (minusp child)
                           (setf proc
                                 (make-process
                                  :input input-stream
                                  :output output-stream
                                  :error error-stream
                                  :status-hook status-hook
                                  :cookie cookie
                                  #-win32 :pty #-win32 pty-stream
                                  :%status :running
                                  :pid child
                                  #+win32 :copiers #+win32 *handlers-installed*
                                  #+win32 :handle #+win32 handle))
                           (push proc *active-processes*))))
                     ;; Report the error outside the lock.
                     (case child
                       (-1
                        (error "Couldn't fork child process: ~A"
                               (strerror)))
                       (-2
                        (error "Couldn't execute ~S: ~A"
                               progname (strerror)))
                       (-3
                        (error "Couldn't change directory to ~S: ~A"
                               directory (strerror))))))))))
      (dolist (fd *close-in-parent*)
        (sb-unix:unix-close fd))
      (unless proc
        (dolist (fd *close-on-error*)
          (sb-unix:unix-close fd))
        #-win32
        (dolist (handler *handlers-installed*)
          (remove-fd-handler handler)))
      (when (and wait proc)
        (unwind-protect
             (process-wait proc)
          #-win32
          (dolist (handler *handlers-installed*)
            (remove-fd-handler handler)))))
    proc))

;;; Install a handler for any input that shows up on the file
;;; descriptor. The handler reads the data and writes it to the
;;; stream.
#-win32
(defun copy-descriptor-to-stream (descriptor stream cookie external-format)
  (incf (car cookie))
  (let* ((handler nil)
         (buf (make-array 256 :element-type '(unsigned-byte 8)))
         (read-end 0)
         (et (stream-element-type stream))
         (copy-fun
          (cond
            ((member et '(character base-char))
             (lambda ()
               (let* ((decode-end read-end)
                      (string (handler-case
                                  (octets-to-string
                                   buf :end read-end
                                   :external-format external-format)
                                (end-of-input-in-character (e)
                                  (setf decode-end
                                        (octet-decoding-error-start e))
                                  (octets-to-string
                                   buf :end decode-end
                                   :external-format external-format)))))
                 (unless (zerop (length string))
                   (write-string string stream)
                   (when (/= decode-end (length buf))
                     (replace buf buf :start2 decode-end :end2 read-end))
                   (decf read-end decode-end)))))
            (t
             (lambda ()
               (handler-bind
                   ((type-error
                      (lambda (c)
                        (error 'simple-type-error
                                         :format-control
                                         "Error using ~s for program output:~@
                                          ~a"
                                         :format-arguments
                                         (list stream c)
                                         :expected-type
                                         (type-error-expected-type c)
                                         :datum
                                         (type-error-datum c)))))
                 (write-sequence buf stream :end read-end))
               (setf read-end 0))))))
    (setf handler
          (add-fd-handler
           descriptor
           :input
           (lambda (fd)
             (declare (ignore fd))
             (loop
                (unless handler
                  (return))
                (multiple-value-bind
                      (result readable/errno)
                    (sb-unix:unix-select (1+ descriptor)
                                         (ash 1 descriptor)
                                         0 0 0)
                  (cond ((null result)
                         (if (eql sb-unix:eintr readable/errno)
                             (return)
                             (error "~@<Couldn't select on sub-process: ~
                                        ~2I~_~A~:>"
                                    (strerror readable/errno))))
                        ((zerop result)
                         (return))))
                (multiple-value-bind (count errno)
                    (with-pinned-objects (buf)
                      (sb-unix:unix-read descriptor
                                         (sap+ (vector-sap buf) read-end)
                                         (- (length buf) read-end)))
                  (cond
                    ((and #-win32 (or (and (null count)
                                           (eql errno sb-unix:eio))
                                      (eql count 0))
                          #+win32 (<= count 0))
                     (remove-fd-handler handler)
                     (setf handler nil)
                     (decf (car cookie))
                     (sb-unix:unix-close descriptor)
                     (unless (zerop read-end)
                       ;; Should this be an END-OF-FILE?
                       (error "~@<non-empty buffer when EOF reached ~
                               while reading from child: ~S~:>" buf))
                     (return))
                    ((null count)
                     (remove-fd-handler handler)
                     (setf handler nil)
                     (decf (car cookie))
                     (error
                      "~@<couldn't read input from sub-process: ~
                                     ~2I~_~A~:>"
                      (strerror errno)))
                    (t
                     (incf read-end count)
                     (funcall copy-fun))))))))
    (push handler *handlers-installed*)))

#+win32
(defun copy-descriptor-to-stream (descriptor stream cookie external-format)
  (declare (ignore cookie))
  (push (sb-win32::make-io-copier :pipe descriptor
                                  :stream stream
                                  :external-format external-format)
        *handlers-installed*))

;;; FIXME: something very like this is done in SB-POSIX to treat
;;; streams as file descriptor designators; maybe we can combine these
;;; two?  Additionally, as we have a couple of user-defined streams
;;; libraries, maybe we should have a generic function for doing this,
;;; so user-defined streams can play nicely with RUN-PROGRAM (and
;;; maybe also with SB-POSIX)?
(defun get-stream-fd-and-external-format (stream direction)
  (typecase stream
    (fd-stream
     (values (fd-stream-fd stream) nil (stream-external-format stream)))
    (synonym-stream
     (get-stream-fd-and-external-format
      (resolve-synonym-stream stream) direction))
    (two-way-stream
     (ecase direction
       (:input
        (get-stream-fd-and-external-format
         (two-way-stream-input-stream stream) direction))
       (:output
        (get-stream-fd-and-external-format
         (two-way-stream-output-stream stream) direction))))))

(defun get-temporary-directory ()
  #-win32 (or (sb-ext:posix-getenv "TMPDIR")
              "/tmp")
  #+win32 (or (sb-ext:posix-getenv "TEMP")
              "C:/Temp"))


;;; Find a file descriptor to use for object given the direction.
;;; Returns the descriptor. If object is :STREAM, returns the created
;;; stream as the second value.
(defun get-descriptor-for (argument object cookie
                           &rest keys
                           &key direction (external-format :default) wait
                           &allow-other-keys)
  (declare (ignore wait)) ;This is explained below.
  ;; Our use of a temporary file dates back to very old CMUCLs, and
  ;; was probably only ever intended for use with STRING-STREAMs,
  ;; which are ordinarily smallish.  However, as we've got
  ;; user-defined stream classes, we can end up trying to copy
  ;; arbitrarily much data into the temp file, and so are liable to
  ;; run afoul of disk quotas or to choke on small /tmp file systems.
  (labels ((fail (format &rest arguments)
             (error "~s error processing ~s argument:~% ~?" 'run-program argument format arguments))
           (make-temp-fd ()
             (multiple-value-bind (fd name/errno)
                 (sb-unix:sb-mkstemp (format nil "~a/.run-program-XXXXXX"
                                             (get-temporary-directory))
                                     #o0600)
               (unless fd
                 (fail "could not open a temporary file: ~A"
                       (strerror name/errno)))
               #+win32
               (setf (sb-win32::inheritable-handle-p fd) t)
               ;; Can't unlink an open file on Windows
               #-win32
               (unless (sb-unix:unix-unlink name/errno)
                 (sb-unix:unix-close fd)
                 (fail "failed to unlink ~A" name/errno))
               fd)))
    (let ((dev-null #.(coerce #-win32 "/dev/null" #+win32 "nul" 'base-string)))
      (cond ((eq object t)
             ;; No new descriptor is needed.
             (values -1 nil))
            ((or (eq object nil)
                 (and (typep object 'broadcast-stream)
                      (not (broadcast-stream-streams object))))
             ;; Use /dev/null.
             (multiple-value-bind
                   (fd errno)
                 (sb-unix:unix-open dev-null
                                    (case direction
                                      (:input sb-unix:o_rdonly)
                                      (:output sb-unix:o_wronly)
                                      (t sb-unix:o_rdwr))
                                    #o666
                                    #+win32 :overlapped #+win32 nil)
               (unless fd
                 (fail "~@<couldn't open ~S: ~2I~_~A~:>"
                       dev-null (strerror errno)))
               #+win32
               (setf (sb-win32::inheritable-handle-p fd) t)
               (push fd *close-in-parent*)
               (values fd nil)))
            ((eq object :stream)
             (multiple-value-bind (read-fd write-fd) (sb-unix:unix-pipe)
               (unless read-fd
                 (fail "couldn't create pipe: ~A" (strerror write-fd)))
               #+win32
               (setf (sb-win32::inheritable-handle-p read-fd)
                     (eq direction :input)
                     (sb-win32::inheritable-handle-p write-fd)
                     (eq direction :output))
               (case direction
                 (:input
                    (push read-fd *close-in-parent*)
                    (push write-fd *close-on-error*)
                    (let ((stream (make-fd-stream write-fd :output t
                                                         :element-type :default
                                                         :external-format
                                                         external-format)))
                      (values read-fd stream)))
                 (:output
                    (push read-fd *close-on-error*)
                    (push write-fd *close-in-parent*)
                    (let ((stream (make-fd-stream read-fd :input t
                                                         :element-type :default
                                                         :external-format
                                                         external-format)))
                      (values write-fd stream)))
                 (t
                    (sb-unix:unix-close read-fd)
                    (sb-unix:unix-close write-fd)
                    (fail "Direction must be either :INPUT or :OUTPUT, not ~S."
                           direction)))))
            ((or (pathnamep object) (stringp object))
             ;; GET-DESCRIPTOR-FOR uses &allow-other-keys, so rather
             ;; than munge the &rest list for OPEN, just disable keyword
             ;; validation there.
             (with-open-stream (file (or (apply #'open object
                                                :allow-other-keys t
                                                #+win32 :overlapped #+win32 nil
                                                keys)
                                         ;; :if-input-does-not-exist nil
                                         ;; can result in this
                                         (return-from get-descriptor-for)))
               (multiple-value-bind
                     (fd errno)
                   (sb-unix:unix-dup (fd-stream-fd file))
                 (cond (fd
                        (push fd *close-in-parent*)
                        (values fd nil))
                       (t
                        (fail "couldn't duplicate file descriptor: ~A"
                              (strerror errno)))))))
          ((streamp object)
           (ecase direction
             (:input
              (block nil
                ;; If we can get an fd for the stream, let the child
                ;; process use the fd for its descriptor.  Otherwise,
                ;; we copy data from the stream into a temp file, and
                ;; give the temp file's descriptor to the
                ;; child.
                (multiple-value-bind (fd stream format)
                    (get-stream-fd-and-external-format object :input)
                  (declare (ignore format))
                  (when fd
                    (return (values fd stream))))
                ;; FIXME: if we can't get the file descriptor, since
                ;; the stream might be interactive or otherwise
                ;; block-y, we can't know whether we can copy the
                ;; stream's data to a temp file, so if RUN-PROGRAM was
                ;; called with :WAIT NIL, we should probably error.
                ;; However, STRING-STREAMs aren't fd-streams, but
                ;; they're not prone to blocking; any user-defined
                ;; streams that "read" from some in-memory data will
                ;; probably be similar to STRING-STREAMs.  So maybe we
                ;; should add a STREAM-INTERACTIVE-P generic function
                ;; for problems like this?  Anyway, the machinery is
                ;; here, if you feel like filling in the details.
                #|
                (when (and (null wait) #<some undetermined criterion>)
                  (error "~@<don't know how to get an fd for ~A, and so ~
                             can't ensure that copying its data to the ~
                             child process won't hang~:>" object))
                |#
                (let ((fd (make-temp-fd))
                      (et (stream-element-type object)))
                  (cond ((member et '(character base-char))
                         (loop
                           (multiple-value-bind
                                 (line no-cr)
                               (read-line object nil nil)
                             (unless line
                               (return))
                             (let ((vector (string-to-octets
                                            line
                                            :external-format external-format)))
                               (sb-unix:unix-write
                                fd vector 0 (length vector)))
                             (if no-cr
                               (return)
                               (sb-unix:unix-write
                                fd #.(string #\Newline) 0 1)))))
                        (t
                         (handler-bind
                             ((type-error
                                (lambda (c)
                                  (error 'simple-type-error
                                         :format-control
                                         "Error using ~s for program input:~@
                                          ~a"
                                         :format-arguments
                                         (list object c)
                                         :expected-type
                                         (type-error-expected-type c)
                                         :datum
                                         (type-error-datum c)))))
                           (loop with buf = (make-array 256 :element-type '(unsigned-byte 8))
                                 for p = (read-sequence buf object)
                                 until (zerop p)
                                 do (sb-unix:unix-write fd buf 0 p)))))
                  (sb-unix:unix-lseek fd 0 sb-unix:l_set)
                  (push fd *close-in-parent*)
                  (return (values fd nil)))))
             (:output
              (block nil
                ;; Similar to the :input trick above, except we
                ;; arrange to copy data from the stream.  This is
                ;; slightly saner than the input case, since we don't
                ;; buffer to a file, but I think we may still lose if
                ;; there's unflushed data in the stream buffer and we
                ;; give the file descriptor to the child.
                (multiple-value-bind (fd stream format)
                    (get-stream-fd-and-external-format object :output)
                  (declare (ignore format))
                  (when fd
                    (return (values fd stream))))
                (multiple-value-bind (read-fd write-fd)
                    #-win32 (sb-unix:unix-pipe)
                    #+win32 (sb-win32::make-named-pipe)
                  (unless read-fd
                    (fail "couldn't create pipe: ~S" (strerror write-fd)))
                  #+win32
                  (setf (sb-win32::inheritable-handle-p write-fd) t)
                  (copy-descriptor-to-stream read-fd object cookie
                                             external-format)
                  (push read-fd *close-on-error*)
                  (push write-fd *close-in-parent*)
                  (return (values write-fd nil)))))))
          (t
           (fail "invalid option: ~S" object))))))
